home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacPerl 4.1.3 / lib / bigrat.pl < prev    next >
Encoding:
Text File  |  1993-10-23  |  4.1 KB  |  135 lines  |  [TEXT/MPS ]
  1. os or
  2. #   white space.
  3. # This package makes use of the bigint package.
  4. # The string 'NaN' is used to represent the result when input arguments 
  5. #   that are not numbers, as well as the result of dividing by zero and
  6. #       the sqrt of a negative number.
  7. # Extreamly naive algorthims are used.
  8. #
  9. # Routines provided are:
  10. #
  11. #   rneg(RAT) return RAT                negation
  12. #   rabs(RAT) return RAT                absolute value
  13. #   rcmp(RAT,RAT) return CODE           compare numbers (undef,<0,=0,>0)
  14. #   radd(RAT,RAT) return RAT            addition
  15. #   rsub(RAT,RAT) return RAT            subtraction
  16. #   rmul(RAT,RAT) return RAT            multiplication
  17. #   rdiv(RAT,RAT) return RAT            division
  18. #   rmod(RAT) return (RAT,RAT)          integer and fractional parts
  19. #   rnorm(RAT) return RAT               normalization
  20. #   rsqrt(RAT, cycles) return RAT       square root
  21.  
  22. # Convert a number to the canonical string form m|^[+-]\d+/\d+|.
  23. sub main'rnorm { #(string) return rat_num
  24.     local($_) = @_;
  25.     s/\s+//g;
  26.     if (m#^([+-]?\d+)(/(\d*[1-9]0*))?$#) {
  27.     &norm($1, $3 ? $3 : '+1');
  28.     } else {
  29.     'NaN';
  30.     }
  31. }
  32.  
  33. # Normalize by reducing to lowest terms
  34. sub norm { #(bint, bint) return rat_num
  35.     local($num,$dom) = @_;
  36.     if ($num eq 'NaN') {
  37.     'NaN';
  38.     } elsif ($dom eq 'NaN') {
  39.     'NaN';
  40.     } elsif ($dom =~ /^[+-]?0+$/) {
  41.     'NaN';
  42.     } else {
  43.     local($gcd) = &'bgcd($num,$dom);
  44.     if ($gcd ne '+1') { 
  45.         $num = &'bdiv($num,$gcd);
  46.         $dom = &'bdiv($dom,$gcd);
  47.     } else {
  48.         $num = &'bnorm($num);
  49.         $dom = &'bnorm($dom);
  50.     }
  51.     substr($dom,0,1) = '';
  52.     "$num/$dom";
  53.     }
  54. }
  55.  
  56. # negation
  57. sub main'rneg { #(rat_num) return rat_num
  58.     local($_) = &'rnorm($_[0]);
  59.     tr/-+/+-/ if ($_ ne '+0/1');
  60.     $_;
  61. }
  62.  
  63. # absolute value
  64. sub main'rabs { #(rat_num) return $rat_num
  65.     local($_) = &'rnorm($_[0]);
  66.     substr($_,0,1) = '+' unless $_ eq 'NaN';
  67.     $_;
  68. }
  69.  
  70. # multipication
  71. sub main'rmul { #(rat_num, rat_num) return rat_num
  72.     local($xn,$xd) = split('/',&'rnorm($_[0]));
  73.     local($yn,$yd) = split('/',&'rnorm($_[1]));
  74.     &norm(&'bmul($xn,$yn),&'bmul($xd,$yd));
  75. }
  76.  
  77. # division
  78. sub main'rdiv { #(rat_num, rat_num) return rat_num
  79.     local($xn,$xd) = split('/',&'rnorm($_[0]));
  80.     local($yn,$yd) = split('/',&'rnorm($_[1]));
  81.     &norm(&'bmul($xn,$yd),&'bmul($xd,$yn));
  82. }
  83.  
  84. # addition
  85. sub main'radd { #(rat_num, rat_num) return rat_num
  86.     local($xn,$xd) = split('/',&'rnorm($_[0]));
  87.     local($yn,$yd) = split('/',&'rnorm($_[1]));
  88.     &norm(&'badd(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd));
  89. }
  90.  
  91. # subtraction
  92. sub main'rsub { #(rat_num, rat_num) return rat_num
  93.     local($xn,$xd) = split('/',&'rnorm($_[0]));
  94.     local($yn,$yd) = split('/',&'rnorm($_[1]));
  95.     &norm(&'bsub(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd));
  96. }
  97.  
  98. # comparison
  99. sub main'rcmp { #(rat_num, rat_num) return cond_code
  100.     local($xn,$xd) = split('/',&'rnorm($_[0]));
  101.     local($yn,$yd) = split('/',&'rnorm($_[1]));
  102.     &bigint'cmp(&'bmul($xn,$yd),&'bmul($yn,$xd));
  103. }
  104.  
  105. # int and frac parts
  106. sub main'rmod { #(rat_num) return (rat_num,rat_num)
  107.     local($xn,$xd) = split('/',&'rnorm($_[0]));
  108.     local($i,$f) = &'bdiv($xn,$xd);
  109.     if (wantarray) {
  110.     ("$i/1", "$f/$xd");
  111.     } else {
  112.     "$i/1";
  113.     }   
  114. }
  115.  
  116. # square root by Newtons method.
  117. #   cycles specifies the number of iterations default: 5
  118. sub main'rsqrt { #(fnum_str[, cycles]) return fnum_str
  119.     local($x, $scale) = (&'rnorm($_[0]), $_[1]);
  120.     if ($x eq 'NaN') {
  121.     'NaN';
  122.     } elsif ($x =~ /^-/) {
  123.     'NaN';
  124.     } else {
  125.     local($gscale, $guess) = (0, '+1/1');
  126.     $scale = 5 if (!$scale);
  127.     while ($gscale++ < $scale) {
  128.         $guess = &'rmul(&'radd($guess,&'rdiv($x,$guess)),"+1/2");
  129.     }
  130.     "$guess";          # quotes necessary due to perl bug
  131.     }
  132. }
  133.  
  134. 1;
  135.